home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLMATH.C < prev    next >
Text File  |  1985-01-01  |  6KB  |  317 lines
  1. /* xlmath - xlisp builtin arithmetic functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack;
  7. extern NODE *true;
  8.  
  9. /* forward declarations */
  10. FORWARD NODE *unary();
  11. FORWARD NODE *binary();
  12. FORWARD NODE *predicate();
  13. FORWARD NODE *compare();
  14.  
  15. /* xadd - builtin function for addition */
  16. NODE *xadd(args)
  17.   NODE *args;
  18. {
  19.     return (binary(args,'+'));
  20. }
  21.  
  22. /* xsub - builtin function for subtraction */
  23. NODE *xsub(args)
  24.   NODE *args;
  25. {
  26.     return (binary(args,'-'));
  27. }
  28.  
  29. /* xmul - builtin function for multiplication */
  30. NODE *xmul(args)
  31.   NODE *args;
  32. {
  33.     return (binary(args,'*'));
  34. }
  35.  
  36. /* xdiv - builtin function for division */
  37. NODE *xdiv(args)
  38.   NODE *args;
  39. {
  40.     return (binary(args,'/'));
  41. }
  42.  
  43. /* xrem - builtin function for remainder */
  44. NODE *xrem(args)
  45.   NODE *args;
  46. {
  47.     return (binary(args,'%'));
  48. }
  49.  
  50. /* xmin - builtin function for minimum */
  51. NODE *xmin(args)
  52.   NODE *args;
  53. {
  54.     return (binary(args,'m'));
  55. }
  56.  
  57. /* xmax - builtin function for maximum */
  58. NODE *xmax(args)
  59.   NODE *args;
  60. {
  61.     return (binary(args,'M'));
  62. }
  63.  
  64. /* xbitand - builtin function for bitwise and */
  65. NODE *xbitand(args)
  66.   NODE *args;
  67. {
  68.     return (binary(args,'&'));
  69. }
  70.  
  71. /* xbitior - builtin function for bitwise inclusive or */
  72. NODE *xbitior(args)
  73.   NODE *args;
  74. {
  75.     return (binary(args,'|'));
  76. }
  77.  
  78. /* xbitxor - builtin function for bitwise exclusive or */
  79. NODE *xbitxor(args)
  80.   NODE *args;
  81. {
  82.     return (binary(args,'^'));
  83. }
  84.  
  85. /* binary - handle binary operations */
  86. LOCAL NODE *binary(args,fcn)
  87.   NODE *args; int fcn;
  88. {
  89.     int ival,iarg;
  90.     NODE *val;
  91.  
  92.     /* get the first argument */
  93.     ival = xlmatch(INT,&args)->n_int;
  94.  
  95.     /* treat '-' with a single argument as a special case */
  96.     if (fcn == '-' && args == NULL)
  97.     ival = -ival;
  98.  
  99.     /* handle each remaining argument */
  100.     while (args) {
  101.  
  102.     /* get the next argument */
  103.     iarg = xlmatch(INT,&args)->n_int;
  104.  
  105.     /* accumulate the result value */
  106.     switch (fcn) {
  107.     case '+':    ival += iarg; break;
  108.     case '-':    ival -= iarg; break;
  109.     case '*':    ival *= iarg; break;
  110.     case '/':    ival /= iarg; break;
  111.     case '%':    ival %= iarg; break;
  112.     case 'M':    if (iarg > ival) ival = iarg; break;
  113.     case 'm':    if (iarg < ival) ival = iarg; break;
  114.     case '&':    ival &= iarg; break;
  115.     case '|':    ival |= iarg; break;
  116.     case '^':    ival ^= iarg; break;
  117.     }
  118.     }
  119.  
  120.     /* initialize value */
  121.     val = newnode(INT);
  122.     val->n_int = ival;
  123.  
  124.     /* return the result value */
  125.     return (val);
  126. }
  127.  
  128. /* xbitnot - bitwise not */
  129. NODE *xbitnot(args)
  130.   NODE *args;
  131. {
  132.     return (unary(args,'~'));
  133. }
  134.  
  135. /* xabs - builtin function for absolute value */
  136. NODE *xabs(args)
  137.   NODE *args;
  138. {
  139.     return (unary(args,'A'));
  140. }
  141.  
  142. /* xadd1 - builtin function for adding one */
  143. NODE *xadd1(args)
  144.   NODE *args;
  145. {
  146.     return (unary(args,'+'));
  147. }
  148.  
  149. /* xsub1 - builtin function for subtracting one */
  150. NODE *xsub1(args)
  151.   NODE *args;
  152. {
  153.     return (unary(args,'-'));
  154. }
  155.  
  156. /* unary - handle unary operations */
  157. LOCAL NODE *unary(args,fcn)
  158.   NODE *args; int fcn;
  159. {
  160.     NODE *val;
  161.     int ival;
  162.  
  163.     /* get the argument */
  164.     ival = xlmatch(INT,&args)->n_int;
  165.     xllastarg(args);
  166.  
  167.     /* compute the result */
  168.     switch (fcn) {
  169.     case '~':    ival = ~ival; break;
  170.     case 'A':    if (ival < 0) ival = -ival; break;
  171.     case '+':    ival++; break;
  172.     case '-':    ival--; break;
  173.     }
  174.  
  175.     /* convert the value  */
  176.     val = newnode(INT);
  177.     val->n_int = ival;
  178.  
  179.     /* return the result value */
  180.     return (val);
  181. }
  182.  
  183. /* xminusp - is this number negative? */
  184. NODE *xminusp(args)
  185.   NODE *args;
  186. {
  187.     return (predicate(args,'-'));
  188. }
  189.  
  190. /* xzerop - is this number zero? */
  191. NODE *xzerop(args)
  192.   NODE *args;
  193. {
  194.     return (predicate(args,'Z'));
  195. }
  196.  
  197. /* xplusp - is this number positive? */
  198. NODE *xplusp(args)
  199.   NODE *args;
  200. {
  201.     return (predicate(args,'+'));
  202. }
  203.  
  204. /* xevenp - is this number even? */
  205. NODE *xevenp(args)
  206.   NODE *args;
  207. {
  208.     return (predicate(args,'E'));
  209. }
  210.  
  211. /* xoddp - is this number odd? */
  212. NODE *xoddp(args)
  213.   NODE *args;
  214. {
  215.     return (predicate(args,'O'));
  216. }
  217.  
  218. /* predicate - handle a predicate function */
  219. LOCAL NODE *predicate(args,fcn)
  220.   NODE *args; int fcn;
  221. {
  222.     NODE *val;
  223.     int ival;
  224.  
  225.     /* get the argument */
  226.     ival = xlmatch(INT,&args)->n_int;
  227.     xllastarg(args);
  228.  
  229.     /* compute the result */
  230.     switch (fcn) {
  231.     case '-':    ival = (ival < 0); break;
  232.     case 'Z':    ival = (ival == 0); break;
  233.     case '+':    ival = (ival > 0); break;
  234.     case 'E':    ival = ((ival & 1) == 0); break;
  235.     case 'O':    ival = ((ival & 1) != 0); break;
  236.     }
  237.  
  238.     /* return the result value */
  239.     return (ival ? true : NULL);
  240. }
  241.  
  242. /* xlss - builtin function for < */
  243. NODE *xlss(args)
  244.   NODE *args;
  245. {
  246.     return (compare(args,'<'));
  247. }
  248.  
  249. /* xleq - builtin function for <= */
  250. NODE *xleq(args)
  251.   NODE *args;
  252. {
  253.     return (compare(args,'L'));
  254. }
  255.  
  256. /* equ - builtin function for = */
  257. NODE *xequ(args)
  258.   NODE *args;
  259. {
  260.     return (compare(args,'='));
  261. }
  262.  
  263. /* xneq - builtin function for /= */
  264. NODE *xneq(args)
  265.   NODE *args;
  266. {
  267.     return (compare(args,'#'));
  268. }
  269.  
  270. /* xgeq - builtin function for >= */
  271. NODE *xgeq(args)
  272.   NODE *args;
  273. {
  274.     return (compare(args,'G'));
  275. }
  276.  
  277. /* xgtr - builtin function for > */
  278. NODE *xgtr(args)
  279.   NODE *args;
  280. {
  281.     return (compare(args,'>'));
  282. }
  283.  
  284. /* compare - common compare function */
  285. LOCAL NODE *compare(args,fcn)
  286.   NODE *args; int fcn;
  287. {
  288.     NODE *arg1,*arg2;
  289.     int cmp;
  290.  
  291.     /* get the two arguments */
  292.     arg1 = xlarg(&args);
  293.     arg2 = xlarg(&args);
  294.     xllastarg(args);
  295.  
  296.     /* do the compare */
  297.     if (stringp(arg1) && stringp(arg2))
  298.     cmp = strcmp(arg1->n_str,arg2->n_str);
  299.     else if (fixp(arg1) && fixp(arg2))
  300.     cmp = arg1->n_int - arg2->n_int;
  301.     else
  302.     cmp = arg1 - arg2;
  303.  
  304.     /* compute result of the compare */
  305.     switch (fcn) {
  306.     case '<':    cmp = (cmp < 0); break;
  307.     case 'L':    cmp = (cmp <= 0); break;
  308.     case '=':    cmp = (cmp == 0); break;
  309.     case '#':    cmp = (cmp != 0); break;
  310.     case 'G':    cmp = (cmp >= 0); break;
  311.     case '>':    cmp = (cmp > 0); break;
  312.     }
  313.  
  314.     /* return the result */
  315.     return (cmp ? true : NULL);
  316. }
  317.